functor ConstCond (S : CONST_COND_STRUCTS) : CONST_COND =
struct
  open S
  
  
  structure Cfg = Cfg
  
  local open Cfg
  in structure Id = Id
     structure Intl = Intl
     structure T = Types
     structure B = Binop
     structure O = Operand
     structure K = Block
     structure S = Structs
     structure J = Transfer
     structure M = Stm
     structure F = Function
     structure P = Program
  end
  
  val tag = !Control.doShowOptVerbose
  fun debugPrint s =
      if tag
      then print s
      else ()
  
  val {get = index, set = setIndex, destroy = destroyIndex, ...} :
      {get : Id.t -> int list, set : Id.t * int list -> unit, destroy : unit -> unit} =
      Property.destGetSet (Id.plist, Property.initConst [])
 
  fun cookBlock (graph, getName, labelNode, b) =
      case b
       of K.T {name,
              prop,
              stms,
              transfer,
              successors} =>
          let val new =
                  case transfer
                   of J.If {line, value, truee, falsee} =>
                      (case value
                        of O.True =>
                           let val nodePred = labelNode name
                               val nodeDeleted = labelNode (falsee)
                               val predsOfDeleted = DiGraph.predecessors (graph, nodeDeleted)
                               fun calIndex (l, n) =
                                   case l
                                    of [] => raise Fail "compiler bug"
                                     | x :: xs =>
                                       if DiGraph.Node.equals (x, nodePred)
                                       then n
                                       else calIndex (xs, n + 1)
                               fun doit l =
                                   let val old = index falsee
                                   in  setIndex (falsee, calIndex (l, 0) :: old)
                                   end
                               val _ = doit predsOfDeleted
                           in  K.T {name = name,
                                    prop = prop,
                                    stms = stms,
                                    transfer = J.Jump {line = line, label = truee},
                                    successors = [truee]}
                           end
                         | O.False =>
                           let val nodePred = labelNode (name)
                               val nodeDeleted = labelNode (truee)
                               val predsOfDeleted = DiGraph.predecessors (graph, nodeDeleted)
                               fun calIndex (l, n) =
                                   case l
                                    of [] => raise Fail "compiler bug"
                                     | x :: xs =>
                                       if DiGraph.Node.equals (x, nodePred)
                                       then n
                                       else calIndex (xs, n + 1)
                               fun doit l =
                                   let val old = index truee
                                   in  setIndex (truee, calIndex (l, 0) :: old)
                                   end
                               val _ = doit predsOfDeleted
                           in  K.T {name = name,
                                  prop = prop,
                                  stms = stms,
                                  transfer = J.Jump {line = line, label = falsee},
                                  successors = [falsee]}
                           end
                         | _ => b)
                    | _ => b
          in  new
          end
         
  fun loopBlocks (graph, getName, labelNode, blocks) =
      List.map (fn x => cookBlock (graph, getName, labelNode, x)) blocks 
  
  fun adjustPhiSrc (index, src) =
      let fun cookSome l = List.map (fn x => SOME x) l
          fun doSrc (i, src) =
              let fun doit (l, n) =
                      case l
                       of [] => []
                        | x :: xs =>
                          if i = n
                          then NONE :: xs
                          else x :: doit (xs, n+1) 
              in  doit (src, 0)
              end
          fun doIndex (l, src) =
              case l
               of [] => src
                | i :: is =>
                  let val new = doSrc (i, src)
                  in  doIndex (is, new)
                  end
          fun clean l =
              case l
               of [] => []
                | NONE :: xs => clean xs
                | SOME x :: xs => x :: clean xs
          val new = doIndex (index, cookSome src)
      in  clean new
      end
        
  fun adjustPhiStms (index, s) =
      case s
       of [] => []
        | (M.Phi {line, dest, src}) :: xs =>
          let val newSrc = adjustPhiSrc (index, src)
              val newPhi = if List.length newSrc = 1
                           then M.Assign {line = line,
                                          dest = dest,
                                          src = #operand (hd newSrc),
                                          ty = T.Intt}
                           else M.Phi {line = line,
                                       dest = dest,
                                       src = newSrc}
          in  newPhi :: adjustPhiStms (index, xs)
          end
        | _ => s
        
  fun adjustPhiBlock b =
      case b
       of K.T {name,
              prop,
              stms,
              transfer,
              successors} =>
          let val deleteList = index (name)
              val new = adjustPhiStms (deleteList, stms)
          in  K.T {name = name,
                   prop = prop,
                   stms = new,
                   transfer = transfer,
                   successors = successors}
          end
      
  fun adjustPhiBlocks blocks = List.map adjustPhiBlock blocks
  
  fun shrinkFunc f =
      case f
       of F.T {name,
               exit,
                rettype,
                args,
                locals,
                blocks,
                pre,
                post} =>
          let val {graph, getName, labelNode, ...} = F.setNameGraph f
              val newBlocks = loopBlocks (graph, getName, labelNode, blocks)
              val newBlocks = adjustPhiBlocks newBlocks
              val new = F.T {name = name,
                             exit = exit,
                             rettype = rettype,
                             args = args,
                             locals = locals,
                             blocks = newBlocks,
                             pre = pre,
                             post = post}
              val _ = debugPrint "\noutput the graph after constant conditions\n"
              val _ = if tag
                      then F.toDot (new, "afterConstCond")
                      else ()
              val _ = destroyIndex ()
          in  new
          end
  
  fun shrinkProg f =
      case f
       of P.T {structs, gvars, funcs, ...} =>
          let val _ = ()
          in  P.T {structs = structs,
                   gvars = gvars,
                   funcs = List.map shrinkFunc funcs}
          end
  
  fun shrink f=
      let val _ = debugPrint "\nconstant conditions starting\n"
          val new = shrinkProg f
          val _ = debugPrint "\nconstant conditions finished\n"
      in  new
      end
end
